home *** CD-ROM | disk | FTP | other *** search
/ The X-Philes (2nd Revision) / The X-Philes Number 1 (1995).iso / xphiles / hp48_2 / yatsrc_d < prev    next >
Internet Message Format  |  1995-03-31  |  22KB
  1. From: Detlef Mueller <detlef@mwhh.hanse.de>
  2. Subject:  v04i029:  yatsrc_dm - Source of YAT v1.4, Part01/01
  3. Newsgroups: comp.sources.hp48
  4. Keywords: HP48 game sys-RPL source TETRIS
  5. Organization: Nothin' is organized here.
  6. Followup-To: comp.sys.hp48
  7. Approved: spell@seq.uncwil.edu
  8.  
  9. Checksum: 3529862805 (verify with brik -cv)
  10. Submitted-by: Detlef Mueller <detlef@mwhh.hanse.de>
  11. Posting-number: Volume 4, Issue 29
  12. Archive-name: yatsrc_dm/part01
  13.  
  14.  
  15. BEGIN_DOC Tetris.doc
  16. Hi folks.
  17.  
  18. Because I've no time to support YAT (Yet Another Tetris) any more, I release
  19. the source.
  20.  
  21. I made YAT using the HP RPL development toolkit; to build the library you
  22. need to have a MesS-DOS machine with the HP stuff installed. Process the
  23. following steps:
  24.     1) Cut out the listings and put them into the appropriate files
  25.     2) Run MKTET.BAT
  26.     3) Now you can download TETRIS.LIB into your HP48
  27.  
  28. For further information see the article 'v03i023:  yat_dm - Yet Another Tetris
  29. version 1.4, Part01/01', published on Feb-16-92 in comp.sources.hp48.
  30.  
  31. Bye,
  32.     8-Detlef
  33.  
  34. P.S.    BTW, is somebody using the RPL:2.1 library ? Because I'm working on
  35.     the 2.2 release, I would be interrested in suggestions. DM
  36. END_DOC
  37.  
  38. BEGIN_SRC mktet.bat
  39. RPLCOMP tetris.S tetris.A tetris.EXT
  40. SASM -e -N tetris
  41. MAKEROM tetris.MN tetris.M
  42. SASM -e -N tHEAD
  43. SASM -e -N tHASH
  44. SASM -e -N tEND
  45. SLOAD tetris.M
  46. SLOAD -H t.M
  47. END_SRC
  48.  
  49. BEGIN_SRC tetris.mn
  50. TITLE Tetris Library
  51. OUTPUT t.o
  52. LLIST t.lr
  53. CONFIGURE TEcfg
  54. NAME TETRIS:1.4,(c)DM'92
  55. ROMPHEAD thead.a
  56. REL tetris.o
  57. TABLE thash.a
  58. FINISH tend.a
  59. END
  60. END_SRC
  61.  
  62. BEGIN_SRC t.m
  63. TITLE Tetris library
  64. OUTPUT tetris.lib
  65. OPTION CODE
  66. LLIST tetris.lr
  67. SUPPRESS XR
  68. SEARCH entries.o
  69. REL t.o
  70. CK LIB301 SYSEND301
  71. END_SRC
  72.  
  73. BEGIN_SRC tetris.s
  74. *****************************************************************************
  75. * Modulname:    TETRIS
  76. * Modultype:    Library
  77. * Dest.Comp.:    HP48
  78. * Language:    System RPL
  79. * Author:    Detlef Mueller,Bellerbek 33,2000 Hamburg 56,Germany
  80. * Interface:    TETRIS
  81. * Description:    The game 'TETRIS' was originally writen by Lennart Boerjeson
  82. *        (freeware), greatly modified by Raymond Hellstern, and now
  83. *        rewriten from DM.
  84. *        This library uses the number 769 because nobody would really
  85. *        interested in the CASINO48 module (I think ?!).
  86. * To do:    --
  87. * Edition History :
  88. *    0.000 08.08.1991 DM    Alpha version
  89. *    0.100 17.08.1991 DM    Change to bint
  90. *    1.000 24.08.1991 DM    1st offical release
  91. *      100 25.08.1991 DM    minor changes
  92. *      200 25.08.1991 DM    correct/condense stone data
  93. *      300 09.09.1991 DM    add pause screen
  94. *      400 19.09.1991 DM    fix some things
  95. *      401 22.12.1991 DM    fix ERRTRAP, first line clear
  96. *      402 21.01.1992 DM    Georg-version.Lines marked with ( ** )
  97. *      403 20.03.1992 DM    release source
  98. * Copyright :
  99. *    (c) 1992 by Detlef Mueller. ALL rights reserved.
  100. *****************************************************************************
  101.  
  102.     TITLE    TETRIS
  103.  
  104. *****************************************************************************
  105. *        INCLUDE FILES
  106. *****************************************************************************
  107.  
  108.  
  109.     INCLUDE    keydefs.h
  110.  
  111. *****************************************************************************
  112. *        ROM ID DEFINITIONS -> 769
  113. *****************************************************************************
  114.  
  115.  
  116. xROMID        301
  117.  
  118. ASSEMBLE
  119.  
  120. GAROMID        EQU    #301
  121. DOBIND        EQU    #074E4
  122.  
  123.     NIBASC    /HPHP48-E/        Binary download header
  124.  
  125. MKGROB    MACRO        * x,y
  126.     CON(5)    =DOGROB
  127.     CON(5)    15+(($1+7)/8)*$2*2
  128.     CON(5)    $2
  129.     CON(5)    $1
  130. MKGROB    ENDM
  131.  
  132. MKSGROB    MACRO        * x,y,nnnn
  133.     CON(5)    =DOGROB
  134.     CON(5)    15+(($1+7)/8)*$2*2
  135.     CON(5)    $2
  136.     CON(5)    $1
  137.     NIBHEX    $3
  138. MKSGROB    ENDM
  139.  
  140. RPL
  141.  
  142.  
  143. *****************************************************************************
  144. *        EXTERNAL DEFINITIONS
  145. *****************************************************************************
  146.  
  147.  
  148. EXTERNAL    xTETRIS
  149.  
  150. EXTERNAL    Install
  151. EXTERNAL    Play
  152. EXTERNAL    Byebye
  153. EXTERNAL    UpdatVal
  154. EXTERNAL    LinesUp
  155. EXTERNAL    LevelUp
  156. EXTERNAL    StIsDown
  157. EXTERNAL    Actions
  158. EXTERNAL    ChkKeys
  159. EXTERNAL    MoveStX
  160. EXTERNAL    Pause
  161. EXTERNAL    StoneHandler
  162. EXTERNAL    Stones
  163.  
  164.  
  165. *****************************************************************************
  166. *        DEFINES
  167. *****************************************************************************
  168.  
  169.  
  170. DEFINE    SetSt        1GETLAM EVAL    ( *'Set stone'* )
  171. DEFINE    TstSt        2GETEVAL    ( *'Test stone'* )
  172. DEFINE    @Timer        3GETLAM        ( *Timing value* )
  173. DEFINE    !Timer        3PUTLAM
  174. DEFINE    @NxtStIm    4GETLAM        ( *Next stone image* )
  175. DEFINE    !NxtStIm    4PUTLAM
  176. DEFINE    @NxtStNo    5GETLAM        ( *Next stone number* )
  177. DEFINE    !NxtStNo    5PUTLAM
  178. DEFINE    @Level        6GETLAM        ( *Level* )
  179. DEFINE    !Level        6PUTLAM
  180. DEFINE    @Score        7GETLAM        ( *Score* )
  181. DEFINE    !Score        7PUTLAM
  182. DEFINE    @Lines        8GETLAM        ( *Full lines* )
  183. DEFINE    !Lines        8PUTLAM
  184. DEFINE    @StNo        9GETLAM        ( *Stone number* )
  185. DEFINE    !StNo        9PUTLAM
  186. DEFINE    @StDir        10GETLAM    ( *Stone direction* )
  187. DEFINE    !StDir        10PUTLAM
  188. DEFINE    @StFt        11GETLAM    ( *Stone falltime* )
  189. DEFINE    !StFt        11PUTLAM
  190. DEFINE    @A        12GETLAM    ( *Temporary A* )
  191. DEFINE    !A        12PUTLAM
  192.  
  193. DEFINE    ClrDrpReq    ONE ClrUserFlag    ( *Stone drop request flag* )
  194. DEFINE    SetDrpReq    ONE SetUserFlag
  195. DEFINE    DrpReq?        ONE TestUserFlag
  196. DEFINE    ClrQuit        TWO ClrUserFlag    ( *Quit game request* )
  197. DEFINE    SetQuit        TWO SetUserFlag
  198. DEFINE    Quit?        TWO TestUserFlag
  199. DEFINE    ClrPreV        THREE ClrUserFlag ( *Preview on/off* )
  200. DEFINE    SetPreV        THREE SetUserFlag
  201. DEFINE    PreV?        THREE TestUserFlag
  202.  
  203.  
  204. *****************************************************************************
  205. *        OBJECTS
  206. *****************************************************************************
  207.  
  208.  
  209. *** TEcfg *******************************************************************
  210. * Interface :    ( --> )
  211. * Description :    Attach this library
  212. * Ed. History :
  213. *     1.000    07.08.1991    DM    start
  214. *****************************************************************************
  215.  
  216. ASSEMBLE
  217. =TEcfg
  218. RPL
  219. ::
  220.     [#] GAROMID TOSRRP            ( *Autoattach* )
  221. ;
  222.  
  223. *** xTETRIS *****************************************************************
  224. * Interface :    ( --> )
  225. * Description :    Main program TETRIS
  226. * Ed. History :
  227. *     1.000    08.08.1991    DM    start
  228. *****************************************************************************
  229.  
  230. ASSEMBLE
  231.     CON(1)    8        * Tell parser 'Non algebraic'
  232. RPL
  233. xNAME    TETRIS
  234. ::
  235.     CK0
  236.     ClrDA1IsStat RECLAIMDISP TURNMENUOFF
  237.     ERRSET
  238.     ::    Install                ( *Install TETRIS* )
  239.     Play                ( *Do it* )
  240.     Byebye                ( *Game over ..* )
  241.     ;
  242.     ERRTRAP
  243.     ::    TURNMENUON RECLAIMDISP
  244.     ERROR@ JstGETTHEMSG
  245.     "TETRIS Failed"
  246.     DISPROW1 DISPROW2 SetDA1Temp
  247.     ;
  248.     ATTNFLGCLR FLUSHKEYS
  249. ;
  250.  
  251. *** Install *****************************************************************
  252. * Interface :    ( --> )
  253. * Description :    Setup TETRIS environment, init game screen
  254. * Ed. History :
  255. *     1.000    08.08.1991    DM    start
  256. *****************************************************************************
  257.  
  258. NULLNAME    Install
  259. ::
  260.     ZEROZEROZERO ZEROZEROZERO ZERO    ( *Initial: A, falltime, stone dir,* )
  261.                     ( *nr, lines, score, level* )
  262.     %RAN %7 %* %IP># #1+DUP        ( *Determine first stone nr.* )
  263.     Stones SWAP NTHCOMPDROP CARCOMP    ( *Determine first stone image* )
  264.     % 0.19                ( *Timer value = .19 - lev * .0171* )
  265.     StoneHandler INCOMPDROP        ( *Tst/SetStone* )
  266.     ' NULLLAM TWELVE NDUPN DOBIND    ( *Generate game environment* )
  267.                     ( *Setup screen* )
  268.     FORTYTHREE ZEROOVER SIXTY        ( *Draw field* )
  269.     84 ZEROOVER 4PICK
  270.     6PICK OVER 4PICK OVER
  271.     LINEON LINEON LINEON
  272.     110 FIFTYSIX "QUIT" MakeStdLabel    ( *Menue lables* )
  273.     88 FIFTYSIX "+LEVL" MakeStdLabel
  274.     TWENTYTWO FIFTYSIX "PVT" MakeStdLabel
  275.     ZERO FIFTYSIX "PAUSE" MakeStdLabel
  276.     TWO THIRTYSIX "LINES" $>grob    ( *Score field* )
  277.     TWO NINETEEN "LEVEL" $>grob
  278.     TWO DUP "SCORE" $>grob
  279.     91 TWO                ( *Help screen* )
  280.     ASSEMBLE
  281.     MKGROB    38,48
  282.     NIBHEX    FFFFFFFFF35240408092FFFFFFFFF30000000000F7FBFBF4E180104805128010
  283.     NIBHEX    480510801048051080F148F4E180104824028010484402801048841280F34805
  284.     NIBHEX    E10000000000FFFFFFFFF35240408092FFFFFFFFF300000000000002E1000000
  285.     NIBHEX    06120000000E040000000E140000000E34000000000000008CFFFFF720C40404
  286.     NIBHEX    0460E4A44494E0F5A4E4B4F1E4A4F5F4E0C44CF7D46084440494200404040400
  287.     NIBHEX    0CFFFFF700048404240004C404640004ECF7E40004F4F5E50004E4E4E40004C4
  288.     NIBHEX    44640004840424000CFFFFF7000000000000000040000000004000000008F300
  289.     NIBHEX    000000F100000000E000000000400000
  290.     RPL
  291.  
  292.     EIGHT
  293.     ZERO_DO (DO)
  294.     XYGROBDISP
  295.     LOOP
  296.  
  297.     FORTYTWO FIFTYSEVEN OVER SIXTYTHREE
  298.     LINEOFF                ( *Clr. last col. of 'PVT'* )
  299.  
  300.     NINE TWENTYSIX FORTYTHREE        ( *Display 0 score/level/lines* )
  301.     THREE
  302.     ZERO_DO (DO)
  303.     ZERO UpdatVal
  304.     LOOP
  305.  
  306.     ClrQuit SetPreV            ( *Init. flags* )
  307.     Pause                ( *Initial screen* )
  308. ;
  309.  
  310. *** Play ********************************************************************
  311. * Interface :    ( --> )
  312. * Description :    Inner TETRIS loop
  313. * Modifies :    StNo StDir NxtStNo NxtStIm StFt Quit
  314. * Ed. History :
  315. *     1.000    08.08.1991    DM    start
  316. *****************************************************************************
  317.  
  318. NULLNAME    Play
  319. ::
  320.     BEGIN
  321.     @NxtStIm @NxtStNo !StNo
  322.     ONE !StDir
  323.  
  324.     Stones %RAN %7 %* %IP># #1+DUP    ( *Determine, ..* )
  325.     !NxtStNo NTHCOMPDROP CARCOMP    ( *.. store next stone nr, get st. blocks* )
  326.     !NxtStIm            ( *Store next stone image* )
  327.  
  328.     PreV? IT
  329.     ::  #C06 ZERO SetSt        ( *Clr preview field* )
  330.         @NxtStIm SWAP
  331.         #F99F SetSt 2DROP        ( *Preview stone at [6,12]* )
  332.     ;
  333.  
  334.     ZERO !StFt            ( *Reset falltime* )
  335.     ClrDrpReq            ( *Clr drop flag* )
  336.     FOURTEEN            ( *Start stone at [14,0]* )
  337.  
  338.     2DUP TstSt #0=ITE        ( *Stone has room ?* )
  339.     ::                ( *Yes* )
  340.         #F99F SetSt            ( *Draw stone in 1st position* )
  341.  
  342.         BEGIN            ( --> hxs stim hxs p )
  343.         DrpReq? ?SKIP        ( *Skip key's if drop req.* )
  344.         ::  THREE
  345.             ZERO_DO (DO)
  346.             ChkKeys        ( *Check for pending keys* )
  347.             LOOP
  348.             @StFt #1+ !StFt    ( *Update falltime* )
  349.             ATTN? NOT?SEMI
  350.             SetQuit        ( *Attn, quick out* )
  351.         ;
  352.         Quit? ?SKIP        ( *Skip on quit req.* )
  353.         ::  ZERO SetSt        ( *Undraw stone* )
  354.             REALOBOB #+        ( *y += 1* )
  355.             2DUP TstSt
  356.             #0=case        ( *Stone down ?* )
  357.             ::    #F99F SetSt    ( *No, draw stone* )
  358.             ;
  359.                     ( *Stone is down* )
  360.             REALOBOB #- #F99F
  361.             SetSt        ( *Draw st. in last pos* )
  362.             DrpReq? case    ( *Drop requested ?* )
  363.             ::  ClrDrpReq    ( *Yes, chance to move stone in x* )
  364.             ;
  365.  
  366.             2DROP ZERO        ( hxs[si] #[pos] --> # *Signal down* )
  367.         ;
  368.         DUP#0= Quit? OR
  369.         UNTIL
  370.     ;
  371.     ::  SetQuit            ( *No room, so quit* )
  372.     ;
  373.  
  374.     #0<> Quit? AND
  375.     ITE
  376.         DROP            ( *Abort by Quit/ATTN* )
  377.         StIsDown            ( *Abort by st. down* )
  378.  
  379.     Quit?                ( *Until quit* )
  380.     UNTIL
  381. ;
  382.  
  383. *** Byebye ******************************************************************
  384. * Interface :    ( --> )
  385. * Description :    TETRIS game over sequence
  386. * Modifies :    A Drop Quit Pv
  387. * Ed. History :
  388. *     1.000    08.08.1991    DM    start
  389. *****************************************************************************
  390.  
  391. NULLNAME    Byebye
  392. ::
  393.     ATTN? ?SKIP                ( *Skip if ATTN pressed* )
  394.     ::    FORTYFOUR TWENTYFIVE
  395.     ASSEMBLE
  396.     MKSGROB 40,7,0000000000C94470757324D6105515AD557055732554105215C5547072750000000000
  397.     RPL
  398.     XYGROBDISP            ( *Show 'Game Over'* )
  399.  
  400.     5400 !A                ( *Generate sound values* )
  401.     THIRTEEN
  402.     ZERO_DO (DO)
  403.         SIX @A DUP 400 #- !A
  404.     LOOP
  405.     THIRTEEN            ( *Generate sound* )
  406.     ZERO_DO (DO)
  407.         setbeep
  408.     LOOP
  409.  
  410.     FLUSHKEYS WaitForKey 2DROP
  411.     ;
  412.  
  413.     ABND                ( *Abandon game environment* )
  414.     ClrQuit ClrPreV            ( *Clear user flags* )
  415.     TURNMENUON RECLAIMDISP        ( *Restore screen* )
  416. ;
  417.  
  418. *** UpdatVal ****************************************************************
  419. * Interface :    ( #y #val --> )
  420. * Description :    Show val at 2,y in medium font on screen
  421. * Ed. History :
  422. *     1.000    18.08.1991    DM    start
  423. *****************************************************************************
  424.  
  425. NULLNAME UpdatVal
  426. ::
  427.     #>$ $>GROB TWO ROT            ( --> grob #2 #y )
  428.     HARDBUFF UNROT            ( --> grob hb #x #y )
  429.     GROB!
  430. ;
  431.  
  432. *** LinesUp *****************************************************************
  433. * Interface :    ( #pos --> #pos )
  434. * Description :    Update game field, increment lines, correct level
  435. * Modifies :    Lines
  436. * Ed. History :
  437. *     1.000    18.08.1991    DM    start
  438. *    001    03.12.1991    DM    clear first row
  439. *****************************************************************************
  440.  
  441. NULLNAME LinesUp
  442. ::
  443.     DUP REALOBOB #/ SWAPDROP #2* #2*     ( #y*4 )
  444.     HARDBUFF FORTYFOUR ZERO 84 5ROLL    ( hb #44 #0 #84 #y )
  445.     SUBGROB                ( grob )
  446.     HARDBUFF FORTYFOUR FOUR GROB!    ( *Clear full line* )
  447.  
  448.     HARDBUFF FORTYFOUR ZERO 84 FOUR GROB!ZERODRP
  449.  
  450.     @Lines #1+DUP !Lines        ( *Update full lines value* )
  451.     FORTYTHREE OVER UpdatVal        ( *Update screen* )
  452.  
  453.     FIFTEEN 400 TWENTYFOUR 300
  454.     setbeep setbeep            ( *Generate full line sound* )
  455.  
  456.     FIVE #/ SWAPDROP @Level #> NOT?SEMI    ( *1 level up* )
  457.  
  458.     NULLNAME    LevelUp            ( --> )
  459.     ::
  460.     TWENTYSIX @Level #1+DUP !Level    ( *Update level value* )
  461.     UpdatVal            ( *Update screen* )
  462.     @Timer % 0.0171 %- % 0.0001 %MAX
  463.     !Timer                ( *Update timer value* )
  464.     ;
  465. ;
  466.  
  467. *** StIsDown ****************************************************************
  468. * Interface :    ( --> )
  469. * Description :    Stone is down, so update score, check if lines are full, et c.
  470. * Modifies :    Score
  471. * Ed. History :
  472. *     1.000    08.08.1991    DM    start
  473. *****************************************************************************
  474.  
  475. NULLNAME StIsDown
  476. ::
  477.     @Score DUP
  478.     @Level PreV? ITE TWO THREE #* TWENTYSEVEN #+ @StFt #- #+DUP
  479.     !Score                ( #o #n *Update score value* )
  480.  
  481.     NINE OVER UpdatVal
  482.  
  483.     1000 #/ SWAPDROPSWAP 1000 #/ SWAPDROP
  484.     #<> IT                ( *Next 1000* )
  485.     ::    SEVEN 700 EIGHT 500
  486.     setbeep setbeep            ( *Generate sound* )
  487.     ;
  488.  
  489.     #E0B                ( *[11,14]* )
  490.     BEGIN
  491.     HXS F 000100200300400 OVER    ( #[pos] hxs[fl] #[pos] )
  492.     2DUP TstSt UNROT        ( #[pos] #[f] hxs[fl] #[pos] )
  493.     #5+                ( *x += 5* )
  494.     TstSt #+ FOUR #=ITE
  495.         LinesUp            ( *Line full* )
  496.     ::  REALOBOB #-            ( *--y* )
  497.     ;
  498.     #200 OVER#>            ( *2 > y* )
  499.     UNTIL DROP
  500.  
  501.     FLUSHKEYS GARBAGE            ( *Clr. key buf., force garbage coll.* )
  502. ;
  503.  
  504. *** ChkKeys *****************************************************************
  505. * Interface :    ( hxs(stim) #(p) --> hxs(stim) #(p) )
  506. * Description :    Check for pending keystroce, perform action, perf. speed ctrl.
  507. * Modifies :    Drop Pv Quit
  508. * Ed. History :
  509. *     1.000    08.08.1991    DM    start
  510. *****************************************************************************
  511.  
  512. NULLNAME    Actions
  513. {
  514.     ::                ( *Rotate stone* )
  515.                 ( hxs[sblk] #p --> hxs[sblk]' #p )
  516.     ZERO SetSt            ( *Clear stone* )
  517.  
  518.     Stones @StNo NTHCOMPDROP
  519.     @StDir #1-
  520.     DUP#0=IT            ( *Get stone images, new direction* )
  521.     ::  DROP DUPLENCOMP
  522.     ;
  523.  
  524.     DUP !A                ( *Store new direction* )
  525.     NTHCOMPDROP SWAP        ( hxs[i] hxs[i'] #[p] )
  526.  
  527.     2DUP TstSt #0=ITE
  528.     ::  ROTDROP @A !StDir
  529.     ;
  530.         SWAPDROP
  531.  
  532.     #F99F SetSt            ( *Draw stone* )
  533.     ;
  534.  
  535.     ::                ( *Stone left* )
  536.     ZERO SetSt
  537.     MINUSONE MoveStX DROP
  538.     #F99F SetSt
  539.     ;
  540.  
  541.     ::                ( *Stone right* )
  542.     ZERO SetSt
  543.     ONE MoveStX DROP
  544.     #F99F SetSt
  545.     ;
  546.  
  547.     ::                ( *Stone left as possible* )
  548.     ZERO SetSt
  549.     BEGIN
  550.         MINUSONE MoveStX
  551.     UNTIL
  552.     #F99F SetSt
  553.     ;
  554.  
  555.     ::                ( *Stone right as possible* )
  556.     ZERO SetSt
  557.     BEGIN
  558.         ONE MoveStX
  559.     UNTIL
  560.     #F99F SetSt
  561.     ;
  562.  
  563.     ::                ( *Drop stone* )
  564.     SetDrpReq
  565.     ;
  566.  
  567.     Pause
  568.  
  569.     ::                ( *Toggle stone preview* )
  570.     THREE DUP TestUserFlag
  571.     case
  572.     ::  ClrUserFlag            ( *Preview off* )
  573.         @NxtStIm #C06 ZERO        ( *Clr preview field* )
  574.         SetSt 2DROP
  575.     ;
  576.     SetUserFlag
  577.     @NxtStIm #C06 #F99F        ( *Preview stone at [20,10]* )
  578.     SetSt 2DROP
  579.     ;
  580.  
  581.     LevelUp
  582.  
  583.     ::                ( *Quit game* )
  584.     SetQuit
  585.     ;
  586.  
  587.     ::                ( *Toggle sound* )
  588.     FIFTYSIX DUP
  589.     TestSysFlag
  590.     case
  591.         ClrSysFlag
  592.     SetSysFlag
  593.     ;
  594. }
  595.  
  596. NULLNAME    ChkKeys
  597. ::
  598.     @Timer dowait            ( *Perform speed control* )
  599.  
  600.     GETTOUCH NOT?SEMI
  601.  
  602.     H/W>KeyCode
  603.     Actions
  604.     {   kcUpArrow kcLeftArrow kcRightArrow
  605.     kcVarsMenu kcNextRow kcDownArrow
  606.     kcMenuKey1 kcMenuKey2 kcMenuKey5 kcMenuKey6
  607.     kcNegate
  608.  
  609. *    kc8 kc4 kc6            ( ** )
  610. *    kc7 kc9 kc5            ( ** )
  611.     }
  612.     ROT ' #= POSCOMP
  613. *    ELEVEN OVER#< IT            ( ** )
  614. *    ::  ELEVEN #-            ( ** )
  615. *    ;                    ( ** )
  616.     NTHELCOMP IT EVAL
  617. ;
  618.  
  619. *** MoveStX *****************************************************************
  620. * Interface :    ( hxs(sblk) #(p) #(stp) --> hxs(sblk) #(p') flag )
  621. * Description :    Move stone x stp, stone left clear on screen
  622. * Modifies :    A
  623. * Ed. History :
  624. *     1.000    08.08.1991    DM    start
  625. *****************************************************************************
  626.  
  627. NULLNAME    MoveStX
  628. ::
  629.     DUP !A                ( *Store step* )
  630.     #+                    ( *New stone pos* )
  631.     2DUP TstSt #0=            ( *Check if stone has room* )
  632.     caseFALSE
  633.  
  634.     @A #- TRUE                ( *No room, so restore pos* )
  635. ;
  636.  
  637. *** Pause *******************************************************************
  638. * Interface :    ( --> )
  639. * Description :    Store, clear game area, show pause grob, wait for key,
  640. *        restore game area.
  641. * Ed. History :
  642. *     1.000    09.09.1991    DM    start
  643. *****************************************************************************
  644.  
  645. NULLNAME    Pause
  646. ::
  647.     FORTYFOUR ZERO 2DUP HARDBUFF UNROT    ( x1 y1 hb x1 y1 )
  648.     84 SIXTY SUBGROB UNROT        ( grob x1 y1 )
  649.     2DUP HARDBUFF UNROT 84 SIXTY GROB!ZERODRP
  650.  
  651.     FORTYFIVE TWENTY
  652.     ASSEMBLE
  653.     MKGROB 37,39
  654.     NIBHEX    080051000008005100000E30510000080051010008984201000C8842C70008EB
  655.     NIBHEX    420100088CF70300049505810004D40501000A84C701000AA405820009C50782
  656.     NIBHEX    0084E585450082B205450089A205290084B68252100FAA83941009AAC6391009
  657.     NIBHEX    AA45521009AAAAEF0001F76D28000114AA28000F14C7EF00011444101001F74C
  658.     NIBHEX    FF300908CF0020880828002084001010208FFFFFFF30C429429460A4294294A0
  659.     NIBHEX    FFFFFFFFF110001100011008020001100802000110080200011008020001FFFF
  660.     NIBHEX    FFFFF1
  661.     RPL
  662.     SIXTY THREE
  663.     ASSEMBLE
  664.     MKSGROB 7,17,8080E38081C0804122141422C1414141C1
  665.     RPL
  666.     XYGROBDISP XYGROBDISP
  667.     WaitForKey 2DROP
  668.     ROT XYGROBDISP
  669.     GARBAGE
  670. ;
  671.  
  672. *** StoneHandler ************************************************************
  673. * Interface :    ( --> {} )
  674. * Description :
  675. * Ed. History :
  676. *     0.000    xx.xx.1991    RH    alpha ver
  677. *     1.000    08.08.1991    DM    start conversion
  678. *    001    17.08.1991    DM    chg to support bint's
  679. *    002    25.08.1991    DM    chg to support HXS x nnn
  680. *****************************************************************************
  681.  
  682. NULLNAME StoneHandler
  683. {
  684.     ::            ( *Test if room* hxs[image] #[pos] --> # )
  685.     TOTEMPOB
  686.  
  687.     CODE
  688. * CPU            A    B    C    D0    D1    Rx
  689.     CD0EX                rsp
  690.     R2=C                            R2=rsp
  691.     BCEX    A            retstk
  692.     R3=C                            R3=retstk
  693.     C=DAT1    A            &#pos
  694.     D0=C                    &#pos
  695.     R1=C                            R1=&#pos
  696.     D0=D0+    5                &pos
  697.     A=0    W
  698.     A=DAT0    A    pos
  699.     R0=A                            R0=pos
  700.     D=D+1    A        *** Pop #[pos] from stack            ***
  701.     D1=D1+    5
  702.     A=DAT1    A    &hxs[i]
  703.     DAT1=C    A        *** hxs becomes #                ***
  704.     AD0EX                    &hxs[i]
  705.     D0=D0+    5                &len
  706.     C=0    W            0
  707.     C=DAT0    2            len
  708.     D0=D0+    5                &imag
  709.     C=C-CON    A,6
  710.     P=C    0
  711.     C=DAT0    WP            imag
  712.     A=C    W    imag
  713.     B=0    W        0
  714. TLoop    B=0    A
  715.     P=    2
  716.     B=C    WP        next coord.
  717.     C=R0                pos
  718.     C=C+B    A            offs
  719.     B=C    A        offs
  720.     BSR    A        >> 4
  721.     P=    2
  722.     B=C    P
  723.     P=    0
  724.     B=0    P
  725.     BSRB.F    A
  726.     P=    2
  727.     C=0    P
  728.     B=B+C    A
  729.     P=    0
  730.     D0=(5)    =VDISP
  731.     C=DAT0    A
  732.     C=C+CON    A,10
  733.     C=C+CON    A,10
  734.     C=C+B    A
  735.     CD0EX
  736.     C=0    W
  737.     C=DAT0    P
  738.     ?C=0    P
  739.     GOYES    TCont4
  740.     B=B+1    S
  741.     GOTO    TCont5
  742. TCont4    P=    15
  743.     LCHEX    8
  744.     P=    0
  745.     B=B!C    S
  746. TCont5    ASR    W
  747.     ASR    W
  748.     ASR    W
  749.     C=A    W
  750.     ?C#0    A
  751.     GOYES    TLoop
  752.     A=0    W
  753.     C=0    W
  754.     A=B    S
  755.     ASLC
  756.     ?ABIT=1    3
  757.     GOYES    TCont6
  758.     C=C+1    A
  759. TCont6    ABIT=0    3
  760.     ?A=0    B
  761.     GOYES    TCont7
  762.     C=C+1    A
  763. TCont7    A=R1        &#pos
  764.     AD0EX                    &#pos
  765.     D0=D0+    5                &pos
  766.     DAT0=C    A
  767.     C=R3                retstk
  768.     BCEX    A        retstk
  769.     C=R2                rsp
  770.     CD0EX                    rsp
  771.     P=    0
  772.     LOOP            *** Jump to next RPL instr. in runstream  ***
  773.  
  774.     ENDCODE
  775.     ;
  776.             ( *Draw image* hxs[image] #[pos] #[patt] --> hxs pos )
  777.     CODE
  778. *  CPU            A    B    C    D0    D1    R0    R1
  779.     A=0    W    0
  780.     GOSBVL    =POP#    patt
  781.     GOSBVL    =SAVPTR
  782.     R1=A                                patt
  783.     GOSBVL    =POP#    pos
  784.     R0=A                            pos
  785.     A=DAT1    A    &hxs
  786.     AD0EX                    &hxs
  787.     D0=D0+    10                &image
  788.     C=0    W            0
  789.     C=DAT0    12            image[12]
  790.     A=C    W    image
  791. XLoop    B=0    W        0
  792.     P=    2
  793.     B=C    WP        C[2]=x
  794.     C=R0                pos
  795.     C=C+B    A            pos+x
  796.     B=C    W        pos+x
  797.     BSR    W        >>= 4
  798.     P=    2
  799.     B=C    P
  800.     P=    0
  801.     B=0    P
  802.     BSRB            B >>= 1
  803.     P=    2
  804.     C=0    P        C[2] = 0
  805.     B=B+C    A        B[A] = offset in screen
  806.     P=    0
  807.     D0=(5)    =VDISP
  808.     C=DAT0    A
  809.     C=C+CON    A,10
  810.     C=C+CON    A,10
  811.     C=C+B    A
  812.     D0=C
  813.     C=R1            C = [patt]
  814.     CSL    W        C <<= 4
  815.     CSL    W        C <<= 4
  816.     P=    4
  817. XCont4    DAT0=C    XS
  818.     CSR    W
  819.     D0=D0+    16
  820.     D0=D0+    16
  821.     D0=D0+    2
  822.     P=P-1
  823.     ?P#    0
  824.     GOYES    XCont4
  825.     ASR    W
  826.     ASR    W
  827.     ASR    W        A >>= 12
  828.     C=A    W
  829.     ?C#0    A
  830.     GOYES    XLoop
  831.     P=    0
  832.     GOSBVL    =GETPTRLOOP    Restore RPL values, dispatch to runstream
  833.  
  834.     ENDCODE
  835. }
  836.  
  837. *** Stones ******************************************************************
  838. * Interface :    ( --> {} )
  839. * Description :
  840. * Ed. History :
  841. *     0.000    xx.xx.1991    RH    alpha ver
  842. *     1.000    08.08.1991    DM    start
  843. *    001    25.08.1991    DM    chg to HXS C xx, correct pos
  844. *****************************************************************************
  845.  
  846. NULLNAME Stones
  847. {
  848.     {   HXS C 301100300200
  849.     HXS C 102202201200
  850.     HXS C 101301201100
  851.     HXS C 102200100101
  852.     }
  853.     {   HXS C 101300200100
  854.     HXS C 202100200201
  855.     HXS C 101301201300
  856.     HXS C 202102101100
  857.     }
  858.     {   HXS C 201100300200
  859.     HXS C 202101200201
  860.     HXS C 101301200201
  861.     HXS C 202301201200
  862.     }
  863.     {   HXS C 101300201200
  864.     HXS C 302201301200
  865.     }
  866.     {   HXS C 301100201200
  867.     HXS C 102201101200
  868.     }
  869.     {   HXS C 000300100200
  870.     HXS C 103102101100
  871.     }
  872.     {   HXS C 201101100200
  873.     }
  874. }
  875.  
  876. *****************************************************************************
  877. *        End of TETRIS.S
  878. *****************************************************************************
  879. END_SRC
  880.  
  881. -- 
  882. +-----------------------------------+---------------------------------------+
  883. |      `What a depressingly         |             Detlef Mueller            |
  884. |         stupid machine`           |          detlef@mwhh.hanse.de         |
  885. |             Marvin                |...!uunet!mcsun!unido!mcshh!mwhh!detlef|
  886. +-----------------------------------+---------------------------------------+
  887.  
  888.